Cream of the Crop 25/Cream of the Crop 25.iso/program/fpk65_66.zip/SOURCE/RTL/DOS/CRT.PP

Text File | 1996-11-15 | 16KB | 669 lines

{****************************************************************************

                        FPKPascal run time library
                         Copyright (c) 1993,96 by
                     Florian Klaempfl & Michael Spiegel

 ****************************************************************************}

{
  history:
  29th may 1994: version 1.0
             unit is completed
  14th june 1994: version 1.01
             the address from which startaddr was read wasn't right; fixed
  18th august 1994: version 1.1
             the upper left corner of winmin is now 0,0
  19th september 1994: version 1.11
             keypressed handles extended keycodes false; fixed
  27th february 1995: version 1.12
             * crtinoutfunc didn't the line wrap in the right way;
               fixed
  20th january 1996: version 1.13
             - unused variables removed
  21th august 1996: version 1.14
             * adapted to newer FPKPascal versions
             * make the comments english
   6th november 1996: version 1.49
             * some stuff for DPMI adapted
  15th november 1996: version 1.5
             * bug in screenrows fixed
}

unit crt;

  interface

    uses
       go32;

    const
       { screen modes }
       bw40 = 0;
       co40 = 1;
       bw80 = 2;
       co80 = 3;
       mono = 7;
       font8x8 = 256;

       { screen color, fore- and background }
       black = 0;
       blue = 1;
       green = 2;
       cyan = 3;
       red = 4;
       magenta = 5;
       brown = 6;
       lightgray = 7;

       { only foreground }
       darkgray = 8;
       lightblue = 9;
       lightgreen = 10;
       lightcyan = 11;
       lightred = 12;
       lightmagenta = 13;
       yellow = 14;
       white = 15;

       { blink flag }
       blink = $80;

    var
       { for compatibility }
       checkbreak,checkeof,checksnow : boolean;

       { wenn true, wird von screeensetcursor die Graphikkarte }
       { direkt programmiert                                   }
       directvideo : boolean;

       lastmode : word; { screen mode}
       textattr : byte; { current text attribute }
       windmin : word; { Rechte obere Ecke des definierten Fensters }
       windmax : word; { Linke untere Ecke des definierten Fensters }

    function keypressed : boolean;
    function readkey : char;
    procedure gotoxy(x,y : byte);
    procedure window(left,top,right,bottom : byte);
    procedure clrscr;
    procedure textcolor(color : byte);
    procedure textbackground(color : byte);
    procedure assigncrt(var f : text);
    function wherex : byte;
    function wherey : byte;
    procedure delline;
    procedure delline(line : byte);
    procedure clreol;
    procedure insline;
    procedure cursoron;
    procedure cursoroff;
    procedure cursorbig;
    procedure lowvideo;
    procedure highvideo;
    procedure nosound;
    procedure sound(hz : word);
    procedure delay(ms : longint);
    procedure textmode(mode : integer);
    procedure normvideo;

  implementation

    var
       maxcols,maxrows : longint;

    type
       pword = ^word;

       textbuf = array[0..127] of char;

       textrec = record
          handle : word;
          mode : word;
          bufSize : word;
          { private : word; PRIVATE is keyword of FPKPascal }
          _private : word;
          bufpos : word;
          bufend : word;
          bufptr : ^textbuf;
          openfunc : pointer;
          inoutfunc : pointer;
          flushfunc : pointer;
          closefunc : pointer;
          userdata : array[1..16] of byte;
          name : string[79];
          buffer : textbuf;
       end;

    { includes low level routines }

    {$i modes.inc}

    function screenrows : byte;

      begin
         dosmemget($40,$84,screenrows,1);
         { don't forget this: }
         inc(screenrows);
      end;

    function screencols : byte;

      begin
         dosmemget($40,$4a,screencols,1);
      end;

    function get_addr(row,col : byte) : word;

      begin
         get_addr:=((row-1)*maxcols+(col-1))*2;
      end;

    procedure screensetcursor(row,col : longint);

      var
         cols : byte;
         pos : word;

      begin
         if directvideo then
           begin
              { set new position for the BIOS }
              dosmemput($40,$51,row,1);
              dosmemput($40,$50,col,1);

              { calculates screen position }
              dosmemget($40,$4a,cols,1);
              { FPKPascal calculates with 32 bit }
              pos:=row*cols+col;

              { direct access to the graphics card registers }
              outportb($3d4,$0e);
              outportb($3d5,hi(pos));
              outportb($3d4,$0f);
              outportb($3d5,lo(pos));
           end
         else
            asm
               movb     $0x02,%ah
               movb     $0,%bh
               movb     row,%dh
               movb     col,%dl
               pushl    %ebp
               int      $0x10
               popl     %ebp
            end;
       end;

    procedure screengetcursor(var row,col : longint);

      begin
         col:=0;
         row:=0;
         dosmemget($40,$50,col,1);
         dosmemget($40,$51,row,1);
      end;

    { exported routines }

    procedure cursoron;

      begin
         asm
            movb   $1,%ah
            movb   $10,%cl
            movb   $9,%ch
            pushl %ebp
            int   $0x10
            popl %ebp
         end;
      end;

    procedure cursoroff;

      begin
         asm
            movb   $1,%ah
            movb   $-1,%cl
            movb   $-1,%ch
            pushl %ebp
            int   $0x10
            popl %ebp
         end;
      end;

    procedure cursorbig;

      begin
         asm
            movb   $1,%ah
            movb   $10,%cl
            movb   $1,%ch
            pushl %ebp
            int   $0x10
            popl %ebp
         end;
      end;

    var
       is_last : boolean;
       last : char;

    function readkey : char;

      var
         char2 : char;
         char1 : char;

      begin
         if is_last then
           begin
              is_last:=false;
              readkey:=last;
           end
         else
           begin
              asm
                 movb $0,%ah
                 pushl %ebp
                 int $0x16
                 popl %ebp
                 movw %ax,-2(%ebp)
              end;
              if char1=#0 then
                begin
                   is_last:=true;
                   last:=char2;
                end;
              readkey:=char1;
           end;
      end;

    function keypressed : boolean;

      begin
         if is_last then
           begin
              keypressed:=true;
              exit;
           end
         else
           asm
              movb $1,%ah
              pushl %ebp
              int $0x16
              popl %ebp
              setnz %al
              movb %al,__RESULT
           end;
      end;

   procedure gotoxy(x,y : byte);

     begin
        if (x<1) then
          x:=1;
        if (y<1) then
          y:=1;
        if y+hi(windmin)-2>=hi(windmax) then
          y:=hi(windmax)-hi(windmin)+1;
        if x+lo(windmin)-2>=lo(windmax) then
          x:=lo(windmax)-lo(windmin)+1;
        screensetcursor(y+hi(windmin)-1,x+lo(windmin)-1);
     end;

   function wherex : byte;

     var
        row,col : longint;

     begin
        screengetcursor(row,col);
        wherex:=col-lo(windmin)+1;
     end;

   function wherey : byte;

     var
        row,col : longint;

     begin
        screengetcursor(row,col);
        wherey:=row-hi(windmin)+1;
     end;

   procedure window(left,top,right,bottom : byte);

     begin
        if (left<1) or
           (right>screencols) or
           (bottom>screenrows) or
           (left>right) or
           (top>bottom) then
           exit;
        windmin:=(left-1) or ((top-1) shl 8);
        windmax:=(right-1) or ((bottom-1) shl 8);
        gotoxy(1,1);
     end;

   procedure clrscr;

     var
        fil : word;
        row : longint;

     begin
        fil:=32 or (textattr shl 8);
        for row:=hi(windmin) to hi(windmax) do
          dosmemfillword($b800,get_addr(row+1,lo(windmin)+1),lo(windmax)-lo(windmin)+1,fil);
        gotoxy(1,1);
     end;

   procedure textcolor(color : Byte);

     begin
        textattr:=(textattr and $70) or color;
     end;

   procedure lowvideo;

     begin
        textattr:=textattr and $f7;
     end;

   procedure highvideo;

     begin
        textattr:=textattr or $08;
     end;

   procedure textbackground(color : Byte);

     begin
        textattr:=(textattr and $8f) or ((color and $7) shl 4);
     end;

   var
      startattrib : byte;

   procedure normvideo;

     begin
        textattr:=startattrib;
     end;

   procedure delline(line : byte);

     var
        row,left,right,bot : longint;
        fil : word;

     begin
        row:=line+hi(windmin);
        left:=lo(windmin)+1;
        right:=lo(windmax)+1;
        bot:=hi(windmax)+1;
        fil:=32 or (textattr shl 8);
        while (row<bot) do
          begin
             dosmemmove($b800,get_addr(row+1,left),$b800,get_addr(row,left),(right-left+1)*2);
             inc(row);
          end;
        dosmemfillword($b800,get_addr(bot,left),right-left+1,fil);
     end;

   procedure delline;

     begin
        delline(wherey);
     end;

   procedure insline;

     var
        row,col,left,right,bot : longint;
        fil : word;

     begin
        screengetcursor(row,col);
        inc(row);
        left:=lo(windmin)+1;
        right:=lo(windmax)+1;
        bot:=hi(windmax);
        fil:=32 or (textattr shl 8);
        while (bot>row) do
          begin
             dosmemmove($b800,get_addr(bot-1,left),$b800,get_addr(bot,left),(right-left+1)*2);
             dec(bot);
          end;
        dosmemfillword($b800,get_addr(row,left),right-left+1,fil);
     end;

   procedure clreol;

     var
        row,col : longint;
        fil : word;

     begin
        screengetcursor(row,col);
        inc(row);
        inc(col);
        fil:=32 or (textattr shl 8);
        dosmemfillword($b800,get_addr(row,col),lo(windmax)-col+2,fil);
     end;

   procedure crtinoutfunc(var f : textrec);

      var
         i,col,row : longint;
         c : char;
         va,sa : word;

      begin
         screengetcursor(row,col);
         inc(row);
         inc(col);
         va:=get_addr(row,col);
         if f.mode=fmoutput then
           begin
              for i:=0 to f.bufpos-1 do
                begin
                   c:=f.buffer[i];
                   case ord(c) of
                      10 : begin
                              inc(row);
                              va:=va+maxcols*2;
                           end;
                      13 : begin
                              col:=lo(windmin)+1;
                              va:=get_addr(row,col);
                          end;
                      8 : if col>lo(windmin)+1 then
                            begin
                               dec(col);
                               va:=va-2;
                            end;
                      7 : begin
                              { beep }
                           end;
                   else
                      begin
                         sa:=textattr shl 8 or ord(c);
                         dosmemput($b800,va,sa,sizeof(sa));
                         inc(col);
                         va:=va+2;
                      end;
                   end;
                   if col>lo(windmax)+1 then
                     begin
                        col:=lo(windmin)+1;
                        inc(row);

                        { it's easier to calculate the new address }
                        { it don't spend much time                 }
                        va:=get_addr(row,col);
                     end;
                   while row>hi(windmax)+1 do
                     begin
                        delline(1);
                        dec(row);
                        va:=va-maxcols*2;
                     end;
                end;
              f.bufpos:=0;
              screensetcursor(row-1,col-1);
           end
         {!!!!!!}
         else halt(100);
      end;

   procedure assigncrt(var f : text);

     begin
        textrec(f).inoutfunc:=@crtinoutfunc;
        textrec(f).flushfunc:=@crtinoutfunc;
     end;

   procedure sound(hz : word);

     begin
        if hz=0 then
          begin
             nosound;
             exit;
          end;
        asm
           movzwl hz,%ecx
           movl $1193046,%eax
           cdql
           divl %ecx
           movl %eax,%ecx
           movb $0xb6,%al
           outb %al,$0x43
           movb %cl,%al
           outb %al,$0x42
           movb %ch,%al
           outb %al,$0x42
           inb $0x61,%al
           orb $0x3,%al
           outb %al,$0x61
        end ['EAX','ECX','EDX'];
     end;

   procedure nosound;

     begin
        asm
           inb $0x61,%al
           andb $0xfc,%al
           outb %al,$0x61
        end ['EAX'];
     end;

   var
      calibration : longint;

   procedure delay(ms : longint);

      var
         i,j : longint;

     begin
        for i:=1 to ms do
          for j:=1 to calibration do
             begin
             end;
     end;

  function get_ticks : word;

    begin
       dosmemget($40,$6c,get_ticks,2);
    end;

  procedure initdelay;

    var
       first : word;

    begin
       calibration:=0;

       { wait for new tick }
       first:=get_ticks;
       while get_ticks=first do
         begin
         end;
       first:=get_ticks;

       { this estimates calibration }
       while get_ticks=first do
         inc(calibration);

       { calculate this to ms }
       calibration:=calibration div 70;
       while true do
         begin
            first:=get_ticks;
            while get_ticks=first do
              begin
              end;
            first:=get_ticks;
            delay(55);
            if first=get_ticks then
               exit
            else begin
                    { decrement calibration two percent }
                    calibration:=calibration-calibration div 50;
                    dec(calibration);
                 end;
         end;
    end;

  procedure textmode(mode : integer);

    var
       set_font8x8 : boolean;

    begin
       lastmode:=mode;
       set_font8x8:=(mode and font8x8)<>0;
       mode:=mode and $ff;
       setscreenmode(mode);
       windmin:=0;
       windmax:=(screencols-1) or ((screenrows-1) shl 8);
       maxcols:=screencols;
       maxrows:=screenrows;
    end;

var
   col,row : longint;

begin
   is_last:=false;

   { direct access to graphics card registers }
   directvideo:=true;

   { set output window }
   windmin:=0;
   windmax:=(screencols-1) or ((screenrows-1) shl 8);

   { load system variables to temporary variables to save time }
   maxcols:=screencols;
   maxrows:=screenrows;

   { save the current settings to restore the old state after the exit }
   screengetcursor(row,col);
   dosmemget($b800,get_addr(row+1,col+1)+1,startattrib,1);
   lastmode:=getscreenmode;
   textattr:=startattrib;

   { redirect the standard output }
   assigncrt(output);

   { calculates delay calibration }
   initdelay;
end.